home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0189.ZIP / SORTER.PAS < prev    next >
Pascal/Delphi Source File  |  1986-02-09  |  24KB  |  698 lines
  1. (***************************************************************)
  2. (*                                                             *)
  3. (*        FILER A LA PASCAL DATA BASE SOURCE CODE FILE         *)
  4. (*                                                             *)
  5. (*        (C) 1985 by  John M. Harlan                          *)
  6. (*                     24000 Telegraph                         *)
  7. (*                     Southfield, MI. 48034                   *)
  8. (*                                                             *)
  9. (*     The FILER GROUP of programs is released on a "FREE      *)
  10. (*     SOFTWARE" basis.  The recipient is free to examine      *)
  11. (*     and use the software with the understanding that if     *)
  12. (*     the FILER GROUP of programs prove to be of use and      *)
  13. (*     value,  a contribution to the author is encouraged.     *)
  14. (*                                                             *)
  15. (*     While reasonable effort has been made to ensure the     *)
  16. (*     reliability of the FILER GROUP of programs, no war-     *)
  17. (*     ranty is given. The recipient uses the programs at      *)
  18. (*     his own risk  and in no event shall the author be       *)
  19. (*     liable for damages arising from their use.              *)
  20. (*                                                             *)
  21. (*                                                             *)
  22. (***************************************************************)
  23.  
  24.  
  25. program sorter; { ONE OF THE FILER GROUP OF PROGRAMS }
  26. {  PROGRAM TO SORT FILES CREATED BY THE FILER GROUP OF PROGRMS  }
  27. {  SORTER.PAS  VERSION 2.0 }
  28. {  INCLUDE FILES : SORT.BOX (PART OF TURBO TOOLBOX) }
  29. {  APR 29, 1985 }
  30.  
  31. { Formatted 2/7/86 by Doug Stevens using Pformat and the Turbo
  32.   editors global search/replace. Original version was 100%
  33.   upper case and very hard to read. }
  34.  
  35. label  QUIT;
  36.  
  37. type
  38.   Range            = array[1..256] of char;
  39.   String60         =  string[60];
  40.   String20         =  string[20];
  41.   NameStr          =  string[12];
  42.  
  43. var
  44.   filerecchgd      : boolean;    { FOR SOURCE FILE }
  45.   recaddedtofile   : boolean;    { FOR SOURCE FILE }
  46.   filerecchgd2     : boolean;    { FOR DESTINATION FILE }
  47.   recaddedtofile2  : boolean;    { FOR DESTINATION FILE }
  48.   fileexists       : boolean;
  49.   nullrecord       : boolean;
  50.   exitflag         : boolean;
  51.  
  52.   ch               : char;
  53.  
  54.   filename         : string[6];
  55.   filedate,
  56.   currdate         : string[8];
  57.   sourcename       : string[14];
  58.   sourcenamedat    : string[14];
  59.   sourcenamebak    : string[14];
  60.   ans              : String60;
  61.   message          : String60;
  62.   thiskey          : String60;
  63.  
  64.   w, x, y, z, code, first, len,
  65.   maxnbrrec, rcdlen,
  66.   blockingfactor, fieldperrecord,
  67.   ascii, keylength                      : integer;
  68.  
  69.   datarecord, diskrecord, precbyte,
  70.   diskrecnowinmem, nbrdiskrecused,
  71.   nbrrecused,lastrecused                : integer;  { FOR SOURCE FILE }
  72.  
  73.   datarecord2, diskrecord2, precbyte2,
  74.   diskrecnowinmem2, nbrdiskrecused2,
  75.   nbrrecused2,lastrecused2              : integer;  { FOR DESTINATION FILE }
  76.  
  77.   numvalue                              :    real;
  78.  
  79.   labellength, datalen, dataform,
  80.   labelposn, dataposn, row,
  81.   column                            :    array[1..32] of integer;
  82.   keyfield                          :    array[0..10] of integer;
  83.   lbl                               :    array[1..384] of char;
  84.   getdata                           :    Range;  { FOR SOURCE FILE }
  85.   outdata                           :    Range;  { FOR DESTINATION FILE }
  86.  
  87.   source                            :    file;
  88.   destination                       :    file;
  89.  
  90. {$ISORT.BOX}           { include sort routine from turbo toolbox }
  91.  
  92. {================================================================}
  93. {        BINARY CODED DECIMAL TO INTEGER FUNCTION                }
  94. {================================================================}
  95. function BcdToInt (cha : char) : integer;
  96. begin
  97.   BcdToInt := ord(cha) - trunc(ord(cha)/16)*6;
  98. end;
  99. {================================================================}
  100. {             CHARACTER TO INTEGER FUNCTION                      }
  101. {================================================================}
  102. function ChrToInt(var charray : Range; start, len : integer)  : integer;
  103. var
  104.   code, result : integer;
  105.   workstring   : string[10];
  106. begin
  107.   workstring := '';
  108.   for result := 0 to len-1  do
  109.     begin
  110.       if charray[start + result ] = ' ' then
  111.         workstring := workstring + '0'
  112.       else workstring := workstring + charray[start+result];
  113.     end;
  114.   val(workstring,result,code);
  115.   ChrToInt := result;
  116. end;
  117. {================================================================}
  118. {               TIDE (EDIT BACKWARDS) PROCEDURE                  }
  119. {================================================================}
  120. procedure Tide( var message : String60);
  121. var w  :  integer;
  122. begin
  123.   for w := length(message) downto 1 do
  124.     begin
  125.       if message[w] in [',', '$', '+'] then
  126.         begin
  127.           delete(message,w,1);
  128.           message := ' ' + message;
  129.         end;
  130.     end;
  131. end;
  132. {===============================================================}
  133. {                      FUNCTION EDITNBR                         }
  134. {===============================================================}
  135. function editnbr(x: real; y,z: integer; dollar: char ) : String20;
  136. var
  137.   numstring : string[24];
  138. begin    { CONVERT THE REAL NUMBER TO A STRING VALUE }
  139.   str(x:18:z,numstring);
  140.   if z = 0 then z := 16  { FIRST POSSIBLE COMMA LOCATION  }
  141.   else z := pos('.',numstring)-3;  {    DITTO             }
  142.  
  143.   while z > 1 do  {  INSERT COMMAS/SPACES IN THE NUMBER  }
  144.     begin
  145.       if numstring[z-1] in [' ','-'] then
  146.         insert(' ',numstring,z)
  147.       else insert(',',numstring,z);
  148.       z := z -3 ;  {  COMMAS OCCUR EVERY THIRD CHARACTER  }
  149.     end;
  150.  
  151.   {  FIND THE FIRST NON SPACE CHARACTER IN THE NUMBER }
  152.   z := 0;
  153.   repeat
  154.     z := z + 1;
  155.  until numstring[z] <> ' ';
  156.  
  157.   { DELETE ANY SPACE FOLLOWING A MINUS SIGN }
  158.   if numstring[z] = '-' then
  159.     begin
  160.       if numstring[z+1] = ' ' then delete(numstring,z+1,1);
  161.       if dollar = '$' then insert('$',numstring,z+1);
  162.     end
  163.  
  164.   { ADD THE $/SPACE CHARACTER TO THE BEGINNING OF THE NUMBER }
  165.   else numstring[z-1] := dollar;
  166.  
  167.   { REPLACE THE NUMBER WITH A FIELD OF '<' IF IT IS TOO BIG  }
  168.   z := length(numstring)-y;
  169.   if numstring[z-1] = '-' then
  170.       for z := y downto 0 do numstring[z] := '<'
  171.   else
  172.     begin
  173.       if numstring[z] in ['0'..'9',',','-','.'] then
  174.           for z := y downto 0 do numstring[z] := '<';
  175.     end;
  176.   editnbr := copy(numstring,z+1,y);
  177.  
  178. end;
  179. {================================================================}
  180. {               STRING TO REAL NUMBER PROCEDURE                  }
  181. {================================================================}
  182. procedure StringToReal(var source:String60;var numb:real;var code:integer);
  183. var
  184.   w  :  integer;
  185.   condition  :  boolean;
  186. begin
  187.   w := 1;
  188.   numb := 0;
  189.   condition := true;
  190.   Tide(source); { ELIMINATE PUNCTUATION }
  191.   repeat  { UNTIL CONDITION = FALSE }
  192.     if source[w] = ' ' then delete(source,1,1)
  193.     else condition := false;
  194.     if length(source) = 0 then
  195.       begin
  196.         source := '0';
  197.         condition := false;
  198.       end;
  199.   until condition = false;
  200.   if length(source) = 1 then condition := true;
  201.   while condition = false do
  202.     begin
  203.       if source[w] = ' ' then
  204.         begin
  205.           condition := true;
  206.           w := w-2;
  207.         end;
  208.       if length(source) = w then
  209.         begin
  210.           condition := true;
  211.           w := w-1;
  212.         end;
  213.       w := w + 1;
  214.     end;
  215.   source := copy(source,1,w);
  216.   val( source,numb,code );
  217. end;
  218. {================================================================}
  219. {           CALCULATE DISKRECORD & PRECBYTE PROCEDURE            }
  220. {================================================================}
  221. procedure Calculate;
  222.   begin
  223.     diskrecord := trunc((datarecord-1)/blockingfactor)*2+7;
  224.     precbyte := ((datarecord-1) mod blockingfactor)*rcdlen;
  225.   end;
  226. {================================================================}
  227. {                   GET DATA RECORD PROCEDURE                    }
  228. {================================================================}
  229. procedure GetDataRec;
  230.   begin
  231.     Calculate;
  232.     if diskrecord <> diskrecnowinmem then
  233.       begin
  234.         if filerecchgd = true then
  235.           begin
  236.             if diskrecnowinmem > nbrdiskrecused then
  237.               begin                 { GET NEXT AVAILABLE RECORD }
  238.                 Seek(source,nbrdiskrecused+2);
  239.                 nbrdiskrecused := diskrecnowinmem;
  240.               end
  241.             else
  242.               begin
  243.                 Seek(source,diskrecnowinmem);
  244.               end;
  245.             blockwrite(source,getdata,2);  {SAVE CHANGED DATA}
  246.             filerecchgd := false;
  247.           end;
  248.         if diskrecord <= nbrdiskrecused then
  249.           begin
  250.             Seek(source,diskrecord);
  251.             blockread(source,getdata,2);         {  RECORD DATA  }
  252.           end
  253.         else FillChar(getdata[1],256,' '); {SPACES FOR EMPTY REC }
  254.         diskrecnowinmem := diskrecord;
  255.       end;
  256.   end;
  257. {================================================================}
  258. {     CALCULATE DESTINATION DISKRECORD & PRECBYTE PROCEDURE      }
  259. {================================================================}
  260. procedure Calculate2;
  261.   begin
  262.     diskrecord2 := trunc((datarecord2-1)/blockingfactor)*2+7;
  263.     precbyte2 := ((datarecord2-1) mod blockingfactor)*rcdlen;
  264.   end;
  265. {================================================================}
  266. {            GET DESTINATION DATA RECORD PROCEDURE               }
  267. {================================================================}
  268. procedure GetDataRec2;
  269.   begin
  270.     Calculate2;
  271.     if diskrecord2 <> diskrecnowinmem2 then
  272.       begin
  273.         if filerecchgd2 = true then
  274.           begin
  275.             if diskrecnowinmem2 > nbrdiskrecused2 then
  276.               begin                 { GET NEXT AVAILABLE RECORD }
  277.                 Seek(destination,nbrdiskrecused2+2);
  278.                 nbrdiskrecused2 := diskrecnowinmem2;
  279.               end
  280.             else
  281.               begin
  282.                 Seek(destination,diskrecnowinmem2);
  283.               end;
  284.             blockwrite(destination,outdata,2);  {SAVE CHANGED DATA}
  285.             filerecchgd2 := false;
  286.           end;
  287.         if diskrecord2 <= nbrdiskrecused2 then
  288.           begin
  289.             Seek(destination,diskrecord2);
  290.             blockread(destination,outdata,2);         {  RECORD DATA  }
  291.           end
  292.         else FillChar(outdata[1],256,' '); {SPACES FOR EMPTY REC }
  293.         diskrecnowinmem2 := diskrecord2;
  294.       end;
  295.   end;
  296. {================================================================}
  297. {               GET DATA FROM ARRAY PROCEDURE                    }
  298. {================================================================}
  299. procedure GetDataFromArray(var message : String60; z : integer);
  300. var w :  integer;
  301. begin
  302.   message := '';
  303.   for w := precbyte+dataposn[z] to precbyte+dataposn[z+1]-1 do
  304.     message := message + getdata[w];
  305. end;
  306. {================================================================}
  307. {                      PROCEDURE INP                             }
  308. {================================================================}
  309. procedure Inp;
  310. begin
  311.   writeln('BUILD KEY FIELDS FOR SORT');
  312.   writeln;
  313.   for datarecord := 1 to nbrrecused do
  314.     begin
  315.       Calculate;
  316.       GetDataRec;
  317.       nullrecord := true;
  318.       y := 1;
  319.       while ( y <= rcdlen) and ( nullrecord = true) do
  320.         begin
  321.           if getdata[precbyte+y] <> ' ' then nullrecord := false;
  322.           y := y+1;
  323.         end;
  324.       if nullrecord = true then nbrrecused := nbrrecused -1
  325.       else
  326.         begin                {  BUILD KEY FIELD FOR SORT  }
  327.           thiskey := '';
  328.           for z := 1 to keyfield[0] do
  329.             begin
  330.               GetDataFromArray(ans,keyfield[z]);
  331.               thiskey := thiskey + ans;
  332.             end;
  333.           str(datarecord:5,ans);
  334.           if length(thiskey)>55 then
  335.             thiskey := copy(thiskey,1,55);
  336.           thiskey := thiskey + ans ;
  337.           writeln(thiskey,'  ');
  338.          sortrelease(thiskey);
  339.        end;
  340.     end;
  341.   writeln;
  342.   writeln;
  343.   writeln('DATA INPUT COMPLETED');
  344.   writeln;
  345.   writeln;
  346.   writeln('..oO[  SORTING  ]Oo..');
  347.   writeln;
  348. end;
  349. {================================================================}
  350. {                       FUNCTION LESS                            }
  351. {================================================================}
  352. function Less;
  353. var
  354.   firststring  :  String60 Absolute x;
  355.   secondstring :  String60 Absolute y;
  356. begin
  357.   Less := firststring < secondstring;
  358. end;
  359. {================================================================}
  360. {                       PROCEDURE OUTP                           }
  361. {================================================================}
  362. procedure Outp;
  363. begin
  364. writeln;
  365. writeln('..oO[  KEY SORT DONE  ]Oo..');
  366. writeln;
  367. writeln;
  368. writeln('..oO[  MOVING RECORDS  ]Oo..');
  369. writeln;
  370. writeln;
  371.   for datarecord2 := 1 to nbrrecused do
  372.     begin
  373.       sortreturn(thiskey);
  374.       ans := copy(thiskey,keylength-4,5);
  375.       for w := 1 to 5  do
  376.         if ans[w] =' ' then ans[w] := '0';
  377.       val(ans,datarecord,code);
  378.       GetDataRec;  { GET SOURCE RECORD }
  379.       GetDataRec2; { GET DESTINATION RECORD }
  380.       for w := 1 to rcdlen do
  381.         outdata[precbyte2+w] := getdata[precbyte+w];
  382.       filerecchgd2 := true;
  383.       GotoXY(1,23);
  384.       write('   RECORD ',datarecord2,' OF ',nbrrecused,' MOVED.');
  385.     end;
  386.     GotoXY(1,23);
  387.     ClrEol;
  388.     writeln;
  389.   if filerecchgd2 = true then
  390.     begin                            { WRITE LAST CHANGED RECORD }
  391.       Seek(destination,diskrecnowinmem2);
  392.       blockwrite(destination,outdata,2)
  393.     end;
  394.   writeln;
  395.   writeln('..oO[  RECORDS MOVED  ]Oo..');
  396.   writeln;
  397.   writeln;
  398. end;
  399. {================================================================}
  400. {                 PRINT LABEL AND FIELD NUMBER                   }
  401. {================================================================}
  402. procedure PrintLabFldNbr( z: integer);
  403. var
  404.   w      :  integer;
  405. begin
  406.   if row[z] <22 then
  407.     begin
  408.       GotoXY(column[z],row[z]);
  409.       for w := labelposn[z] to labelposn[z+1]-1 do
  410.       write (lbl[w]);
  411.       write('= ',z);
  412.     end;
  413. end;
  414. {================================================================}
  415. {                      PRINT LABEL                               }
  416. {================================================================}
  417. procedure PrintLabel( z: integer);
  418. var
  419.   w      :  integer;
  420. begin
  421.   write(z,' : ');
  422.   for w := labelposn[z] to labelposn[z+1]-1 do
  423.   write (lbl[w]);
  424.   writeln;
  425. end;
  426. {================================================================}
  427. {                 DISPLAY ONE RECORD PROCEDURE                   }
  428. {================================================================}
  429. procedure DisplayRec;
  430. begin
  431.   ClrScr;
  432.   for z := 1 to fieldperrecord do
  433.   PrintLabFldNbr(z);
  434.   GotoXY(70,23);
  435.   write('RECORD ',datarecord);
  436.   lastrecused := datarecord;
  437. end;
  438. {===============================================================}
  439. {                       FUNCTION EXIST                          }
  440. {===============================================================}
  441. function Exist(filename : NameStr) : boolean;
  442. var
  443.   fil    :  file;
  444.   status : Integer;
  445. begin
  446.   Assign(fil,filename);
  447.   {$I-}
  448.   reset(fil);
  449.   {$I+}
  450.   Exist := (IOResult = 0);
  451. {$I-} Close(fil); status := IOResult; {$I+} (* Required by Turbo 3.x *)
  452. end;                                        (* Added by Doug Stevens *)
  453. {================================================================}
  454. {           FUNCTION GET NUMBER IN GETDATA FIELD ( Z )           }
  455. {================================================================}
  456. function FnbrInFld(z : integer) : real;
  457. var
  458.   realval : real;
  459.   begin
  460.     GetDataFromArray(ans,z);
  461.     if dataform[z] <> ascii then
  462.       StringToReal(ans,realval,code)
  463.     else realval := 0;
  464.     FnbrInFld := realval;
  465.   end;
  466.  
  467. {================================================================}
  468. {                  INITIALIZE FILER FILE                         }
  469. {================================================================}
  470. procedure Initialize;
  471.  
  472.   label QUIT;
  473.  
  474. begin
  475.   repeat
  476.     ClrScr; exitflag := FALSE;
  477.     TextMode(bw40);
  478.     GotoXY(1,22);
  479.     write('SORTER A LA PASCAL');
  480.     GotoXY(1,23);
  481.     write('ENTER SOURCE FILE NAME : ');
  482.     readln(sourcename);
  483.     x := pos('.',sourcename);
  484.     if x <> 0 then sourcename := copy(sourcename,1,x-1);
  485.     if (sourcename = 'END') then
  486.       begin                      { Quick & dirty exit. }
  487.         exitflag := TRUE;
  488.         goto QUIT;
  489.       end;
  490.     sourcenamedat := sourcename + '.DAT';
  491.     sourcenamebak := sourcename + '.BAK';
  492.     fileexists := Exist(sourcenamedat);
  493.   until fileexists = true;
  494.  
  495.   {========================================}
  496.   {   ERASE ANY BACKUP FILE OF SAME NAME   }
  497.   {========================================}
  498.   if (Exist(sourcenamebak)) then
  499.     begin
  500.       Assign(source,sourcenamebak);
  501.       Erase(source);
  502.       writeln;
  503.       writeln(sourcenamebak,' HAS BEEN DELETED.');
  504.     end;
  505.  
  506.   {========================================}
  507.   {       RENAME FILE TO FILENAME.BAK      }
  508.   {========================================}
  509.   Assign(source,sourcenamedat);
  510.   Rename(source,sourcenamebak);
  511.   reset(source);
  512.   writeln('FILE ',sourcenamedat,' RENAMED ',sourcenamebak);
  513.  
  514.   {=======================================}
  515.   {    CREATE DESTINATION FILENAME.DAT    }
  516.   {=======================================}
  517.   Assign(destination, sourcenamedat);
  518.   rewrite ( destination );
  519.  
  520.   {=======================================}
  521.   {      BUILD HEADER FOR NEW FILE        }
  522.   {=======================================}
  523.   Seek(source,0);
  524.   blockread( source,getdata,1 );          { BASIC/Z BLOCK 0 }
  525.   blockwrite(destination,getdata,1);
  526.  
  527.   blockread( source,getdata,1 );          { FILE PARAMETERS }
  528.   blockwrite(destination,getdata,1);
  529.  
  530.   blockread( source,lbl,3 );                 { FILER LABELS }
  531.   blockwrite(destination,lbl,3);
  532.  
  533.  
  534.   {=================================================}
  535.   {      READ IN HEADER DATA FOR FILER FILE         }
  536.   {=================================================}
  537.   filename := 'XXXXXX';
  538.   for x := 1 to 6 do
  539.     filename[x] := getdata[x];
  540.   maxnbrrec := ChrToInt(getdata,7,4);
  541.   nbrrecused := ChrToInt(getdata,11,4);
  542.   rcdlen := ChrToInt(getdata,15,3);
  543.   blockingfactor := ChrToInt(getdata,18,2);
  544.   fieldperrecord := ChrToInt(getdata,20,2);
  545.   filedate := '  /  /  ';
  546.   Move(getdata[22],filedate[1],8);
  547.  
  548. {================================================================}
  549. {  GET LABEL LENGTH, DATA LENGTH & DATA FORM INFO                }
  550. {================================================================}
  551.  
  552. labelposn[1] := 1;
  553. dataposn[1] := 1;
  554.  
  555. for x := 1 to fieldperrecord do
  556.   begin
  557.     labellength[x] :=  BcdToInt(getdata[32+x]);
  558.     datalen[x]     :=  BcdToInt(getdata[64+x]);
  559.     dataform[x]    :=  ord(getdata[96+x])-48;
  560.     labelposn[x+1] :=  labelposn[x] + labellength[x];
  561.     dataposn[x+1]  :=  dataposn[x] + datalen[x];
  562.   end;
  563.  
  564. {================================================================}
  565. {           TRANSLATE REPORT STRUCTURE                           }
  566. {================================================================}
  567.  
  568.   blockread(source,getdata,1);  { SCREEN INFORMATION }
  569.   blockwrite(destination,getdata,1);
  570.       { ESTABLISH VALUE OF DATAFORM[Z] FOR ASCII INFORMATION }
  571.       if getdata[1] = 'S' then ascii := 9 else ascii := 15;
  572.   for x := 1 to fieldperrecord do
  573.     begin
  574.       w := x*4+1;
  575.       row[x]       := BcdToInt(getdata[w]);
  576.       column[x] := BcdToInt(getdata[w+1])*10+trunc(BcdToInt(getdata[w+2])/10);
  577.       {FIELDNBR[X]  := BCDTOIN(GETDATA[W+3]);} { not implemented }
  578.     end;
  579.   blockread(source,getdata,2);  { REPORT FORMAT INFORMATION (NOT USED) }
  580.   blockwrite(destination,getdata,1);
  581.   blockwrite(destination,getdata,1);    { FIRST RECORD GOES HERE }
  582.   blockwrite(destination,getdata,1);
  583.  
  584. {================================================================}
  585. {          INITIALIZE VARIABLES FOR ENTRY INTO FILER             }
  586. {================================================================}
  587.   datarecord := nbrrecused;                 { SOURCE FILE SET UP }
  588.   Calculate;
  589.   diskrecnowinmem := diskrecord -1; { ENSURE DISK READ FIRST TIME}
  590.   filerecchgd := false;      { ENSURE NO WRITE BEFORE FIRST READ }
  591.   lastrecused := 0;               { SET LAST RECORD USED TO ZERO }
  592.   nbrdiskrecused := diskrecord;     { ESTABLISH MAX DISK REC NBR }
  593.   recaddedtofile := false; { FLAG TO INDICATE CHANGE IN FILE SIZE}
  594.  
  595.   nbrrecused2 := 0;                    { DESTINATION FILE SET UP }
  596.   datarecord2 := nbrrecused2;
  597.   Calculate2;
  598.   diskrecnowinmem2 := diskrecord2 -1; { ENSURE DISK READ FIRST TIME}
  599.   filerecchgd2 := false;       { ENSURE NO WRITE BEFORE FIRST READ }
  600.   lastrecused2 := 0;                { SET LAST RECORD USED TO ZERO }
  601.   nbrdiskrecused2 := diskrecord2;     { ESTABLISH MAX DISK REC NBR }
  602.   recaddedtofile2 := false;  { FLAG TO INDICATE CHANGE IN FILE SIZE}
  603. QUIT:
  604. end;  { INTIIALIZE PROCEDURE }
  605.  
  606.  
  607. {================================================================}
  608. {                         SORT PROGRAM                           }
  609. {================================================================}
  610.  
  611. begin
  612.   Initialize;                   { ID AND READ IN FILE PARAMETERS }
  613.   if exitflag then goto QUIT;   { Quick and dirty exit. }
  614.   TextMode(bw80);
  615.  
  616.   {======================================}
  617.   {           ENTER KEY FIELDS           }
  618.   {======================================}
  619.   repeat
  620.     DisplayRec;
  621.     GotoXY(1,21);
  622.     write('IN ORDER OF IMPORTANCE :');
  623.     x := 1;
  624.     keylength := 0;
  625.     repeat
  626.       ClrEol;
  627.       if x = 1 then
  628.         begin
  629.           GotoXY(1,23);
  630.           write('ENTER KEY FIELD NUMBER : ')
  631.         end
  632.       else
  633.         begin
  634.           GotoXY(1,24);
  635.           write('ENTER RETURN ONLY TO END KEY DEFINITION');
  636.           GotoXY(1,23);
  637.           write('ENTER NEXT KEY FIELD : ');
  638.           ClrEol;
  639.         end;
  640.       ans := '';
  641.       read(ans);
  642.       StringToReal(ans,numvalue,code);
  643.       keyfield[x] := trunc(numvalue);
  644.       if numvalue <> 0 then keylength := keylength + datalen[keyfield[x]];
  645.       x := x + 1;
  646.     until numvalue = 0;
  647.     keyfield[0] := x-2;
  648.     if keylength > 55 then keylength := 55;
  649.     keylength := keylength + 6;  { 5 for field nbr + 1 for string 0 byte }
  650.  
  651.     {=======================================}
  652.     {      DISPLAY KEYS SELECTED            }
  653.     {=======================================}
  654.     ClrScr;
  655.     GotoXY(1,23);
  656.     writeln('KEY FIELDS SELECTED ARE :');
  657.     writeln('=========================');
  658.     writeln;
  659.     for x := 1 to keyfield[0] do
  660.       begin
  661.         PrintLabel(keyfield[x]);
  662.       end;
  663.     writeln;
  664.     writeln('=========================');
  665.     writeln('KEYLENGTH = ',keylength);
  666.     write('IS THIS OK (Y/N) : ');
  667.     readln(ch);
  668.   until (UpCase(ch) = 'Y') or (eoln);
  669.   writeln;
  670.  
  671.   {===============================================}
  672.   {  BUILD KEY FIELDS AND PASS TO TURBO SORT      }
  673.   {===============================================}
  674.  
  675.   writeln(turbosort(keylength)); { CALL TURBO SORT PROGRAM }
  676.                                  { SEE INP, LESS & OUTP    }
  677.                                  { PROCEDURES              }
  678.  
  679. {================================================================}
  680. {                    END PROGRAM                                 }
  681. {================================================================}
  682.  
  683.   Seek(destination,1);
  684.   blockread(destination,getdata,1);
  685.   str(nbrrecused:4,ans);
  686.   Move(ans[1],getdata[11],4);  { UPDATE NBR OF RECORDS }
  687.   Seek(destination,1);
  688.   blockwrite(destination,getdata,1);
  689.   close(source);
  690.   close(destination);
  691.   GotoXY(5,24);
  692.   writeln('[  0 INDICATES SUCCESSFUL SORT  ]');
  693.   writeln;
  694.   writeln;
  695.   writeln('..oO[   HAVE A GREAT DAY!   ]Oo..');
  696. QUIT:
  697. end.
  698.